home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / pattern.t < prev    next >
Text File  |  1988-02-05  |  3KB  |  107 lines
  1. (herald pattern)
  2.  
  3. ;;; An attempt at a general syntax checking mechanism ala JAR's 421 parser
  4.  
  5. ;   #f             any s-expression
  6. ;   FOO            any X such that (FOO X) => #t
  7. ;   (X ... Y)      a list of X ... Y
  8. ;   (X ... Y . Z)  a list of X ... Y and then a cdr of Z
  9. ;   (* X)          proper list of Xs
  10. ;   (@ X)          spliced in list of Xs, this is not valid outside a list
  11. ;   (+ X)          nonempty list of Xs
  12. ;   (| X Y ...)    an X or a Y or ...
  13. ;   (! X)          the symbol X
  14.  
  15. ;;; (pattern-predicate spec) => predicate for spec
  16.  
  17. (define-syntax (pattern-predicate pattern)
  18.   (expand-pattern pattern))
  19.  
  20. ;;; Main dispatch for patterns
  21.  
  22. (define (expand-pattern pattern)
  23.   (cond ((not pattern)
  24.          '(lambda (x) (ignore x) t))
  25.         ((atom? pattern)
  26.          pattern)
  27.         (else
  28.          (case (car pattern)
  29.            ((*) (repetition-pattern (cadr pattern)))
  30.            ((+) (positive-pattern (cadr pattern)))
  31.            ((|) (disjunction-pattern (cdr pattern)))
  32.            ((!) `(lambda (x) (eq? x ',(cadr pattern))))
  33.            ((@) (error "match found @ outside of a sequence in ~S" pattern))
  34.            (else 
  35.             (sequence-pattern pattern))))))
  36.  
  37. (define (repetition-pattern pattern)
  38.   (cond ((eq? pattern '#f)
  39.          'proper-list?)               ; efficiency hack
  40.         (else
  41.          (let ((pred (expand-pattern pattern))
  42.                (l (generate-symbol 'l)))
  43.            `(lambda (,l)
  44.               (iterate loop ((,l ,l))
  45.                 (cond ((null? ,l) t)
  46.                       ((atom? ,l) nil)
  47.                       ((,pred (car ,l)) (loop (cdr ,l)))
  48.                       (else nil))))))))
  49.  
  50. (define (positive-pattern pattern)
  51.   (let ((l (generate-symbol 'l)))
  52.     `(lambda (,l)
  53.        (if (null? ,l)
  54.            nil
  55.            (,(repetition-pattern pattern) ,l)))))
  56.  
  57. (define (disjunction-pattern patterns)
  58.   (let ((x (generate-symbol 'x)))
  59.     `(lambda (,x)
  60.        (or . ,(map (lambda (pattern)
  61.                      `(,(expand-pattern pattern) ,x))
  62.                    patterns)))))
  63.  
  64. (define (sequence-pattern pattern)
  65.   (iterate loop ((p pattern) (preds '()))
  66.     (cond ((null? p)
  67.            (finish-sequence preds 'null?))
  68.           ((atom? p)
  69.            (finish-sequence preds p))
  70.           ((memq? (car p) '(* + | !))
  71.            (finish-sequence preds (expand-pattern p)))
  72.           ((and (pair? (car p))
  73.                 (eq? (caar p) '@))
  74.            (finish-sequence preds (spliced-pattern p)))
  75.           (else
  76.            (loop (cdr p) (cons (expand-pattern (car p)) preds))))))
  77.  
  78. (define (finish-sequence preds final)
  79.   (iterate loop ((preds preds) (form final))
  80.     (if (null? preds)
  81.         form
  82.         (let ((l (generate-symbol 'l)))
  83.           (loop (cdr preds)
  84.                 `(lambda (,l)
  85.                    (and (pair? ,l)
  86.                         (,(car preds) (car ,l))
  87.                         (,form (cdr ,l)))))))))
  88.  
  89. (define (spliced-pattern pattern)
  90.   (let ((pred (expand-pattern (cadar pattern)))
  91.         (l (generate-symbol 'l))
  92.         (p (generate-symbol 'p)))
  93.     `(lambda (,l)
  94.        (let ((,p ,(sequence-pattern (cdr pattern))))
  95.          (iterate loop ((,l ,l))
  96.            (cond ((null? ,l)
  97.                   ,(if (null? (cdr pattern))
  98.                        't
  99.                        `(,p '())))
  100.                  ((atom? ,l)
  101.                   (,p ,l))
  102.                  ((,pred (car ,l))
  103.                   (loop (cdr ,l)))              
  104.                  (else
  105.                   (,p ,l))))))))
  106.  
  107.